home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / src / heap.c < prev    next >
C/C++ Source or Header  |  1992-10-09  |  8KB  |  335 lines
  1. /* Heap management, garbage collection, etc.
  2.  */
  3.  
  4. #include "scheme.h"
  5.  
  6. extern char *sbrk();
  7.  
  8. #define Recursive_Visit(p) {\
  9.     register Object *pp = p;\
  10.     if (Types[TYPE(*pp)].haspointer) Visit (pp);\
  11. }
  12.  
  13. char *Heap_Start,
  14.      *Hp,                     /* First free byte */
  15.      *Heap_End,               /* Points behind free bytes */
  16.      *Free_Start,             /* Start of free area */
  17.      *Free_End;               /* Points behind free area */
  18.  
  19. int GC_In_Progress;
  20.  
  21. GCNODE *GC_List;
  22.  
  23. static GCNODE *Global_GC_Obj;
  24.  
  25. static FUNCT *Before_GC_Funcs, *After_GC_Funcs;
  26.  
  27. static char *To;
  28. static Object V_Garbage_Collect_Notifyp;
  29.  
  30. Init_Heap () {
  31.     Define_Variable (&V_Garbage_Collect_Notifyp, "garbage-collect-notify?",
  32.     True);
  33. }
  34.  
  35. Make_Heap (size) {
  36.     register unsigned k = 1024 * size;
  37.     register unsigned s = 2 * k;
  38.  
  39.     if ((Hp = Heap_Start = (char *)sbrk (s)) == (char *)-1)
  40.     Fatal_Error ("cannot allocate heap (%u KBytes)", 2*size);
  41.     Heap_End = Heap_Start + k;
  42.     Free_Start = Heap_End;
  43.     Free_End = Free_Start + k;
  44.     /* Does last heap address fit?
  45.     */
  46. #ifdef POINTER_CONSTANT_HIGH_BITS
  47.     if ((((unsigned)Free_End-1) & ~POINTER_CONSTANT_HIGH_BITS) > VALMASK)
  48.     Fatal_Error ("heap size too large (%u KBytes max, maybe less)",
  49.         (VALMASK - ((unsigned)Heap_Start & ~POINTER_CONSTANT_HIGH_BITS))
  50.         / 1024 / 2);
  51. #else
  52.     if ((unsigned)Free_End-1 > VALMASK)
  53.     Fatal_Error ("heap size too large (%u KBytes max)",
  54.         (VALMASK - (unsigned)Heap_Start) / 1024 / 2);
  55. #endif
  56. }
  57.  
  58. Object Alloc_Object (size, type, konst) {
  59.     register char *p = Hp;
  60.     Object ret;
  61.  
  62.     if (GC_Debug) {
  63.     (void)P_Collect ();
  64.     p = Hp;
  65.     }
  66.     ALIGN(p);
  67.     if (p + size > Heap_End) {
  68.     (void)P_Collect ();
  69.     p = Hp;
  70.     ALIGN(p);
  71.     if (p + size > Heap_End - HEAP_MARGIN)
  72.         Uncatchable_Error ("Out of heap space");
  73.     }
  74.     Hp = p + size;
  75.     SET(ret, type, p);
  76.     if (konst)
  77.     SETCONST(ret);
  78.     return ret;
  79. }
  80.  
  81. /* Not used by the interpreter kernel (lint may complain).
  82.  */
  83. Register_Before_GC (f) void (*f)(); {
  84.     FUNCT *p;
  85.  
  86.     p = (FUNCT *)Safe_Malloc (sizeof (*p));
  87.     p->func = f;
  88.     p->next = Before_GC_Funcs;
  89.     Before_GC_Funcs = p;
  90. }
  91.  
  92. Call_Before_GC () {
  93.     FUNCT *p;
  94.  
  95.     for (p = Before_GC_Funcs; p; p = p->next)
  96.     p->func();
  97. }
  98.  
  99. Register_After_GC (f) void (*f)(); {
  100.     FUNCT *p;
  101.  
  102.     p = (FUNCT *)Safe_Malloc (sizeof (*p));
  103.     p->func = f;
  104.     p->next = After_GC_Funcs;
  105.     After_GC_Funcs = p;
  106. }
  107.  
  108. Call_After_GC () {
  109.     FUNCT *p;
  110.  
  111.     for (p = After_GC_Funcs; p; p = p->next)
  112.     p->func();
  113. }
  114.  
  115. Object P_Collect () {
  116.     register char *tmp;
  117.     register msg = 0;
  118.     Object a[2];
  119.  
  120.     if (!Interpreter_Initialized)
  121.     Fatal_Error ("heap too small (increase heap size)");
  122.     if (GC_In_Progress)
  123.     Fatal_Error ("GC while GC in progress");
  124.     Disable_Interrupts;
  125.     GC_In_Progress = 1;
  126.     Call_Before_GC ();
  127.     if (GC_Debug) {
  128.     printf ("."); (void)fflush (stdout);
  129.     } else if (Truep (Var_Get (V_Garbage_Collect_Notifyp))) {
  130.     msg++;
  131.     Format (Standard_Output_Port, "[Garbage collecting... ", 23, 0,
  132.         (Object *)0);
  133.     (void)fflush (stdout);
  134.     }
  135.     To = Free_Start;
  136.     Visit_GC_List (Global_GC_Obj, 0);
  137.     Visit_GC_List (GC_List, 0);
  138.     Visit_Wind (First_Wind, 0);
  139.     Hp = To;
  140.     tmp = Heap_Start; Heap_Start = Free_Start; Free_Start = tmp;
  141.     tmp = Heap_End; Heap_End = Free_End; Free_End = tmp;
  142.     if (!GC_Debug) {
  143.     if (msg) {
  144.         a[0] = Make_Fixnum ((Hp-Heap_Start) / 1024);
  145.         a[1] = Make_Fixnum ((Heap_End-Heap_Start) / 1024);
  146.         Format (Standard_Output_Port, "~sK of ~sK]~%", 13, 2, a);
  147.     }
  148.     }
  149.     Call_After_GC ();
  150.     GC_In_Progress = 0;
  151.     Enable_Interrupts;
  152.     return Void;
  153. }
  154.  
  155. Visit (p) register Object *p; {
  156.     register Object *tag;
  157.     register t, size, reloc;
  158.  
  159. again:
  160.     t = TYPE(*p);
  161.     if (!Types[t].haspointer)
  162.     return;
  163.     tag = (Object *)POINTER(*p);
  164.     if ((char *)tag >= Free_Start && (char *)tag < Free_End)
  165.     return;
  166.     if (TYPE(*tag) == T_Broken_Heart) {
  167.     SETPOINTER(*p, POINTER(*tag));
  168.     return;
  169.     }
  170.     ALIGN(To);
  171.     switch (t) {
  172.     case T_Bignum:
  173.     size = sizeof (struct S_Bignum) - sizeof (gran_t)
  174.            + BIGNUM(*p)->size * sizeof (gran_t);
  175.     bcopy ((char *)tag, To, size);
  176.     break;
  177.     case T_Flonum:
  178.     size = sizeof (struct S_Flonum);
  179.     *(struct S_Flonum *)To = *(struct S_Flonum *)tag;
  180.     break;
  181.     case T_Symbol:
  182.     size = sizeof (struct S_Symbol);
  183.     *(struct S_Symbol *)To = *(struct S_Symbol *)tag;
  184.     break;
  185.     case T_Pair:
  186.     case T_Environment:
  187.     size = sizeof (struct S_Pair);
  188.     *(struct S_Pair *)To = *(struct S_Pair *)tag;
  189.     break;
  190.     case T_String:
  191.     size = sizeof (struct S_String) + STRING(*p)->size - 1;
  192.     bcopy ((char *)tag, To, size);
  193.     break;
  194.     case T_Vector:
  195.     size = sizeof (struct S_Vector) + (VECTOR(*p)->size - 1) *
  196.         sizeof (Object);
  197.     bcopy ((char *)tag, To, size);
  198.     break;
  199.     case T_Primitive:
  200.     size = sizeof (struct S_Primitive);
  201.     *(struct S_Primitive *)To = *(struct S_Primitive *)tag;
  202.     break;
  203.     case T_Compound:
  204.     size = sizeof (struct S_Compound);
  205.     *(struct S_Compound *)To = *(struct S_Compound *)tag;
  206.     break;
  207.     case T_Control_Point:
  208.     size = sizeof (struct S_Control) + CONTROL(*p)->size - 1;
  209.     reloc = To - (char *)tag;
  210.     bcopy ((char *)tag, To, size);
  211.     break;
  212.     case T_Promise:
  213.     size = sizeof (struct S_Promise);
  214.     *(struct S_Promise *)To = *(struct S_Promise *)tag;
  215.     break;
  216.     case T_Port:
  217.     size = sizeof (struct S_Port);
  218.     *(struct S_Port *)To = *(struct S_Port *)tag;
  219.     break;
  220.     case T_Autoload:
  221.     size = sizeof (struct S_Autoload);
  222.     *(struct S_Autoload *)To = *(struct S_Autoload *)tag;
  223.     break;
  224.     case T_Macro:
  225.     size = sizeof (struct S_Macro);
  226.     *(struct S_Macro *)To = *(struct S_Macro *)tag;
  227.     break;
  228.     case T_Broken_Heart:
  229.     Panic ("broken heart in GC");
  230.     default:
  231.     if (t < 0 || t >= MAX_TYPE || !Types[t].name)
  232.         Panic ("bad type in GC");
  233.     if (Types[t].size == NOFUNC)
  234.         size = Types[t].const_size;
  235.     else
  236.         size = (*Types[t].size)(*p);
  237.     bcopy ((char *)tag, To, size);
  238.     }
  239.     SETPOINTER(*p, To);
  240.     SET(*tag, T_Broken_Heart, To);
  241.     To += size;
  242.     if (To > Free_End)
  243.     Panic ("free exhausted in GC");
  244.     if (Types[t].visit == NOFUNC)
  245.     return;
  246.     switch (t) {
  247.     case T_Symbol:
  248.     Recursive_Visit (&SYMBOL(*p)->next);
  249.     Recursive_Visit (&SYMBOL(*p)->name);
  250.     Recursive_Visit (&SYMBOL(*p)->value);
  251.     p = &SYMBOL(*p)->plist;
  252.     goto again;
  253.     case T_Pair:
  254.     case T_Environment:
  255.     Recursive_Visit (&PAIR(*p)->car);
  256.     p = &PAIR(*p)->cdr;
  257.     goto again;
  258.     case T_Vector: {
  259.         register i, n;
  260.         for (i = 0, n = VECTOR(*p)->size; i < n; i++)
  261.         Recursive_Visit (&VECTOR(*p)->data[i]);
  262.         break;
  263.     }
  264.     case T_Compound:
  265.     Recursive_Visit (&COMPOUND(*p)->closure);
  266.     Recursive_Visit (&COMPOUND(*p)->env);
  267.     p = &COMPOUND(*p)->name;
  268.     goto again;
  269.     case T_Control_Point:
  270.     Recursive_Visit (&CONTROL(*p)->memsave);
  271.     CONTROL(*p)->delta += reloc;
  272. #ifdef USE_ALLOCA
  273.     Visit_GC_List (CONTROL(*p)->gclist, CONTROL(*p)->delta);
  274. #else
  275.     Recursive_Visit (&CONTROL(*p)->gcsave);
  276. #endif
  277.     Visit_Wind (CONTROL(*p)->firstwind, CONTROL(*p)->delta);
  278.     p = &CONTROL(*p)->env;
  279.     goto again;
  280.     case T_Promise:
  281.     Recursive_Visit (&PROMISE(*p)->env);
  282.     p = &PROMISE(*p)->thunk;
  283.     goto again;
  284.     case T_Port:
  285.     p = &PORT(*p)->name;
  286.     goto again;
  287.     case T_Autoload:
  288.     Recursive_Visit (&AUTOLOAD(*p)->files);
  289.     p = &AUTOLOAD(*p)->env;
  290.     goto again;
  291.     case T_Macro:
  292.     Recursive_Visit (&MACRO(*p)->body);
  293.     p = &MACRO(*p)->name;
  294.     goto again;
  295.     default:
  296.     (*Types[t].visit)(p, Visit);
  297.     }
  298. }
  299.  
  300. Visit_GC_List (list, delta) GCNODE *list; {
  301.     register GCNODE *gp, *p;
  302.     register n;
  303.     register Object *vec;
  304.  
  305.     for (gp = list; gp; gp = p->next) {
  306.     p = (GCNODE *)NORM(gp);
  307.     if (p->gclen <= 0) {
  308.         Visit ((Object *)NORM(p->gcobj));
  309.     } else {
  310.         vec = (Object *)NORM(p->gcobj);
  311.         for (n = 0; n < p->gclen-1; n++)
  312.         Visit (&vec[n]);
  313.     }
  314.     }
  315. }
  316.  
  317. Visit_Wind (list, delta) WIND *list; unsigned delta; {
  318.     register WIND *wp, *p;
  319.  
  320.     for (wp = list; wp; wp = p->next) {
  321.     p = (WIND *)NORM(wp);
  322.     Visit (&p->inout);
  323.     }
  324. }
  325.  
  326. Func_Global_GC_Link (x) Object *x; {
  327.     GCNODE *p;
  328.  
  329.     p = (GCNODE *)Safe_Malloc (sizeof (*p));
  330.     p->gclen = 0;
  331.     p->gcobj = x;
  332.     p->next = Global_GC_Obj;
  333.     Global_GC_Obj = p;
  334. }
  335.